The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpu6.zip/TPU6RPT.PAS

Pascal/Delphi Source File | 1991-04-16 | 5KB | 234 lines

{$D+,S+,L+,R-,I+}

UNIT TPU6RPT;

(*****************)
(**) INTERFACE (**)
(*****************)

USES Dos;
CONST
    Ctl_CRLF = ^M^J;    { "new-line" sequence for MS/PC Dos }
    Ctl_FF   = ^L;        { "new-page" sequence for MS/PC Dos }

TYPE  FileFlags = (FileActive,FileQuiet,FileFailure);

VAR    LinesRemaining,        { on current page }
    ColumnsRemaining,    { on current line }
    ColumnsUsed        { on current line }
            : LongInt;
    FileStatus     : FileFlags;

PROCEDURE PutTxt(S : String);
PROCEDURE PutCtl(S : String);
PROCEDURE SetCol(I : Integer);
PROCEDURE NewTxtLine;
PROCEDURE NewTxtPage;
PROCEDURE OpenTxt(S : String; LineMax, ColumnMax : Integer);
PROCEDURE CloseTxt;

(**********************)
(**) IMPLEMENTATION (**)
(**********************)

CONST
    Ctl_EOF  = ^Z;    { "end-file" sequence for MS/PC Dos }
    Ctl_CR   = ^M;    { "Carriage-Return"                 }
    Ctl_LF   = ^J;    { "Line-Feed"                       }

VAR    MaxLinesOnPage,
    MaxColsPerLine,
    CurrentLine,
    CurrentColumn : LongInt;

    NoLineWrap, NoPageBreak : Boolean;

    FileState : FileFlags;
    TextFile  : Text;
        Spaces    : String;

PROCEDURE FeedBack;
BEGIN
    IF NOT (FileState = FileActive) THEN
    BEGIN
        LinesRemaining   := 0;
        ColumnsRemaining := 0;
        ColumnsUsed      := 0;
    END ELSE
    BEGIN
        LinesRemaining   := MaxLinesOnPage + 1 - CurrentLine;
        ColumnsRemaining := MaxColsPerLine + 1 - CurrentColumn;
        ColumnsUsed      := CurrentColumn  - 1;
    END;
    FileStatus := FileState;
END;    {FeedBack}

PROCEDURE PutCR;
BEGIN
    PutCtl(Ctl_CR);
    CurrentColumn := 1;
END;

PROCEDURE PutLF;
BEGIN
    IF NoPageBreak
    THEN PutCtl(Ctl_LF)
    ELSE
        IF CurrentLine = MaxLinesOnPage THEN
        BEGIN
            PutCtl(Ctl_FF);
            CurrentLine := 0
        END
        ELSE    PutCtl(Ctl_LF);

    Inc(CurrentLine);
END;

PROCEDURE PutCRLF;
BEGIN    PutCR;    PutLF;    END;

PROCEDURE PutFF;
BEGIN    PutCtl(Ctl_FF);    CurrentLine := 1;    END;

PROCEDURE PutEOF;
BEGIN    PutCtl(Ctl_EOF);    END;

FUNCTION ScanCtls(S : String):Integer;
LABEL Found;
VAR J : Integer; I, L : Byte;
BEGIN
    J := 0; L := Length(S);
    FOR I := 1 TO L DO
        IF S[I] in [Ctl_EOF,Ctl_FF,Ctl_LF,Ctl_CR]
        THEN BEGIN
            J := I; GOTO Found
        END;
Found:
    ScanCtls := J
END;

PROCEDURE PutTxt(S : String);
VAR CtlPos, Slice : Integer;
BEGIN
    CtlPos := ScanCtls(S);
    WHILE Length(S) > 0 DO BEGIN
        IF CurrentColumn > MaxColsPerLine THEN PutCRLF;
        IF CurrentLine   > MaxLinesOnPage THEN PutFF;
        Slice := Length(S);
        IF CtlPos = 0
        THEN CtlPos := Slice + 1
        ELSE
            IF Slice > CtlPos
            THEN Slice := CtlPos - 1;
        IF Slice > MaxColsPerLine THEN Slice := MaxColsPerLine;
        IF Slice > 0 THEN
        BEGIN
            PutCtl(Copy(S,1,Slice));
            Delete(S,1,Slice);
            CtlPos := CtlPos - Slice;
            CurrentColumn := CurrentColumn + Slice
        END ELSE
        BEGIN
            IF S[1] = Ctl_EOF THEN PutEOF ELSE
            IF S[1] = Ctl_FF  THEN PutFF  ELSE
            IF S[1] = Ctl_LF  THEN PutLF  ELSE
            IF S[1] = Ctl_CR  THEN PutCR;
            Delete(S,1,1);
            IF Length(S) > 0 THEN CtlPos := ScanCtls(S);
        END;
    END; {WHILE}
    FeedBack;
END;

PROCEDURE PutCtl(S : String);
BEGIN
    IF FileState = FileActive THEN
    BEGIN
        {$I-} Write(TextFile,S); {$I+}
        IF IOResult <> 0 THEN CloseTxt
    END;
END;

PROCEDURE NewTxtLine;
BEGIN
    PutCRLF;
    FeedBack;
END;

PROCEDURE NewTxtPage;
BEGIN
    IF CurrentColumn > 1 THEN PutCRLF;
    IF CurrentLine > 1 THEN PutFF;
    FeedBack;
END;

PROCEDURE OpenTxt(S : String; LineMax, ColumnMax : Integer);
BEGIN
    IF FileState = FileActive THEN CloseTxt;

    Assign(TextFile,S);
    NoPageBreak := (LineMax < 1) OR (LineMax > 255);
    IF NoPageBreak
        THEN MaxLinesOnPage := MaxLongInt
        ELSE MaxLinesOnPage := LineMax;
    NoLineWrap  := (ColumnMax < 1) OR (ColumnMax > 255);
    IF NoLineWrap
        THEN MaxColsPerLine := MaxLongInt
        ELSE MaxColsPerLine := ColumnMax;
    CurrentLine    := 1;
    CurrentColumn  := 1;
    FileState      := FileActive;

    {$I-} ReWrite(TextFile); {$I+}

    IF IOResult <> 0 THEN FileState := FileFailure;
    IF FileState = FileFailure
    THEN CloseTxt
    ELSE FeedBack;
END;

PROCEDURE SetCol(I : Integer);
Var J : Integer;
BEGIN
    IF FileState = FileActive THEN
    IF MaxColsPerLine > I   THEN
    BEGIN
        IF CurrentColumn  > I THEN PutCRLF;
                J := I - CurrentColumn;
                IF J < SizeOf(Spaces) THEN
                BEGIN
                   Spaces[0] := Chr(J);
                   PutTxt(Spaces);
                END ELSE
        WHILE CurrentColumn < I DO PutTxt(' ')
    END;
    FeedBack;
END;

PROCEDURE CloseTxt;
BEGIN
    IF FileState = FileActive THEN
    BEGIN
    {    PutEOF; }
        {$I-} Close(TextFile); {$I+}
        MaxLinesOnPage := 0;
        MaxColsPerLine := 0;
        CurrentLine    := 0;
        CurrentColumn  := 0;
        FileState      := FileQuiet;
        NoLineWrap     := True;
        NoPageBreak    := True;
        FeedBack;
    END;
END;

BEGIN    { UNIT INITIALIZATION CODE }

        FillChar(Spaces,SizeOf(Spaces),' ');
    MaxLinesOnPage := 0;
    MaxColsPerLine := 0;
    CurrentLine    := 0;
    CurrentColumn  := 0;
    FileState      := FileQuiet;
    FeedBack;
END.